home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _55d191448473a0c6b7974214a1de5c59 < prev    next >
Encoding:
Text File  |  2002-05-01  |  10.3 KB  |  417 lines
  1. #=============================================================================
  2. # Package: PPM::PPD
  3. # Purpose: Exposes a simple, object-oriented interfaces to PPDs.
  4. # Notes:
  5. # Author:  Neil Watkiss
  6. #=============================================================================
  7. package PPM::PPD;
  8.  
  9. use strict;
  10. use Data::Dumper;
  11. use XML::Simple ();
  12.  
  13. $PPM::PPD::VERSION = '3.05';
  14.  
  15. sub new {
  16.     my $this = shift;
  17.     my $ppd  = shift;
  18.     my $rep  = shift;    # the repository object that retrieved this PPD
  19.     my $id   = shift;    # the unique key in the repository of this PPD
  20.     die "Error: PPM::PPD constructor called with undef ppd\n" .
  21.       Dumper(caller(0))
  22.         unless defined $ppd;
  23.     my $class = ref($this) || $this;
  24.     my $self = bless {
  25.     rep => $rep,
  26.     id  => $id,
  27.     }, $class;
  28.     $self->init($ppd);
  29.     return $self;
  30. }
  31.  
  32. sub repository {
  33.     my $o = shift;
  34.     $o->{rep};
  35. }
  36. sub id {
  37.     my $o = shift;
  38.     $o->{id};
  39. }
  40.  
  41. sub is_complete {
  42.     my $o = shift;
  43.     $o->{is_complete};
  44. }
  45.  
  46. sub find_impl_raw {
  47.     my $o = shift;
  48.     my $target = shift;
  49.     for my $impl ($o->implementations) {
  50.     my $match = 1;
  51.     for my $field (keys %$impl) {
  52.         next if ref($impl->{$field});
  53.         my $value = $target->config_get($field);
  54.         if ($value && ref($value) && eval { $value->isa("PPM::Result") }) {
  55.         next unless $value->is_success;
  56.         $match &&= ($value->result eq $impl->{$field});
  57.         }
  58.         else {
  59.         next unless defined $value;
  60.         $match &&= ($value eq $impl->{$field});
  61.         }
  62.     }
  63.     return $impl if $match == 1;
  64.     }
  65.     return undef;
  66. }
  67.  
  68. sub find_impl {
  69.     my $o = shift;
  70.     my $target = shift;
  71.     my $impl = $o->find_impl_raw($target);
  72.     # We must not 'use' this, because the ppminst code also uses PPM::PPD, and
  73.     # it doesn't have PPM::Result available.
  74.     require PPM::Result;
  75.     return PPM::Result::Ok($impl) if $impl;
  76.     PPM::Result::Error("no suitable implementation found for '"
  77.                . $o->name . "'.");
  78. }
  79.  
  80. sub name {
  81.     my $o = shift;
  82.     my $r = $o->{parsed}{NAME};
  83.     return defined $r ? $r : "";
  84. }
  85.  
  86. sub title {
  87.     my $o = shift;
  88.     my $r = $o->{parsed}{TITLE};
  89.     return defined $r ? $r : "";
  90. }
  91.  
  92. sub version_osd {
  93.     my $o = shift;
  94.     my $r = $o->{parsed}{VERSION};
  95.     return defined $r ? $r : "";
  96. }
  97.  
  98. sub version {
  99.     my $o = shift;
  100.     my $v = $o->version_osd;
  101.     printify($v);
  102. }
  103.  
  104. sub printify {
  105.     my $v = shift;
  106.     $v =~ s/(?:[\.,]0)*$//;
  107.     $v .= '.0' unless ($v =~ /[\.,]/ or $v eq '');
  108.     $v = "(any version)" if $v eq '';
  109.     $v =~ tr/,/./;
  110.     $v;
  111. }
  112.  
  113. # This sub returns 1 if $ver is >= to $o->version. It returns 0 otherwise.
  114. # Note: this is only used if the repository doesn't know how to compare
  115. # version numbers. The PPM3Server knows how to do it, the others don't.
  116. sub uptodate {
  117.     my $o = shift;
  118.     my $ver = shift;
  119.  
  120.     return 1 if $ver eq $o->version_osd; # shortcut
  121.  
  122.     my @required = split /[\.,]/, $o->version_osd;
  123.     my @proposed = split /[\.,]/, $ver;
  124.  
  125.     for (my $i=0; $i<@required; $i++) {
  126.     no warnings;
  127.     return 0 if $proposed[$i] < $required[$i];    # too old
  128.     return 1 if $proposed[$i] > $required[$i];    # even newer
  129.     }
  130.     return 1; # They're equal
  131. }
  132.  
  133. sub abstract {
  134.     my $o = shift;
  135.     my $r = $o->{parsed}{ABSTRACT};
  136.     return defined $r ? $r : "";
  137. }
  138.  
  139. sub author {
  140.     my $o = shift;
  141.     my $r = $o->{parsed}{AUTHOR};
  142.     return defined $r ? $r : "";
  143. }
  144.  
  145. sub implementations {
  146.     my $o = shift;
  147.     return @{$o->{parsed}{IMPLEMENTATION} || []};
  148. }
  149.  
  150. sub ppd {
  151.     my $o = shift;
  152.     return $o->{ppd};
  153. }
  154.  
  155. sub init {
  156.     my $o = shift;
  157.     my $ppd = shift;
  158.  
  159.     if ($ppd =~ /<SOFTPKG/) {
  160.     $o->{ppd} = $ppd;
  161.     $o->{source} = caller;
  162.     }
  163.     elsif ($ppd !~ m![\n]! && -f $ppd) {
  164.     $o->loadfile($ppd);
  165.     $o->{source} = $ppd;
  166.     }
  167.     else {
  168.     die "PPM::PPD::init: not a PPD and not a file:\n$ppd";
  169.     }
  170.  
  171.     $o->parse;
  172. }
  173.  
  174. sub loadfile {
  175.     my $o = shift;
  176.     my $file = shift;
  177.     open FILE, $file        || die "can't read $file: $!";
  178.     $o->{ppd} = do { local $/; <FILE> };
  179.     close FILE            || die "can't close $file: $!";
  180. }
  181.  
  182. sub parse {
  183.     my $o = shift;
  184.     my $parser = XML::Simple->new(
  185.     forcearray    => 1,
  186.     forcecontent    => 1,
  187.     keyattr        => [],
  188.     suppressempty    => undef,
  189.     );
  190.     my $tree = eval { $parser->XMLin($o->{ppd}) };
  191.     die "error: can't parse $o->{ppd}: $@" if $@;
  192.  
  193.     # First: SOFTPKG attributes:
  194.     $o->{parsed}{NAME}        = $o->conv($tree->{NAME});
  195.     $o->{parsed}{VERSION}    = $o->conv($tree->{VERSION});
  196.  
  197.     # Next: childless elements:
  198.     $o->{parsed}{ABSTRACT}    = $o->conv($tree->{ABSTRACT}[0]{content});
  199.     $o->{parsed}{AUTHOR}    = $o->conv($tree->{AUTHOR}[0]{content});
  200.     $o->{parsed}{TITLE}        = $o->conv($tree->{TITLE}[0]{content});
  201.  
  202.     # Next: IMPLEMENTATION:
  203.     my @impls;
  204.     for my $impl (@{$tree->{IMPLEMENTATION}}) {
  205.     my $i = PPM::PPD::Implementation->new({});
  206.     for my $key (keys %$impl) {
  207.         # Next: DEPENDENCY:
  208.         if ($key eq 'DEPENDENCY') {
  209.         my @deps = @{$impl->{$key}};
  210.         $i->{DEPENDENCY} = 
  211.           [map { PPM::PPD::Dependency->new($_) } @deps];
  212.         next;
  213.         }
  214.         # Next: LANGUAGE:
  215.         if ($key eq 'LANGUAGE') {
  216.         my $v = $impl->{$key}[0];
  217.         my $lang = {
  218.             NAME    => $o->conv($v->{NAME}),
  219.             VERSION    => $o->conv(
  220.             $v->{COMPAT}[0]{VERSION} || $v->{VERSION}
  221.             ),
  222.             TYPE    => $o->conv($v->{COMPAT}[0]{TYPE}),
  223.         };
  224.         $i->{LANGUAGE} = PPM::PPD::Language->new($lang);
  225.         next;
  226.         }
  227.         # Next: INSTALL or UNINSTALL.
  228.         if ($key eq 'INSTALL' or $key eq 'UNINSTALL') {
  229.         my $v = $impl->{$key}[0];
  230.         $i->{"${key}_SCRIPT"} = PPM::PPD::Script->new({
  231.             EXEC    => $o->conv($v->{EXEC}),
  232.             HREF    => $o->conv($v->{HREF}),
  233.             SCRIPT    => $o->conv($v->{content}),
  234.         });
  235.         }
  236.         # Next: CODEBASE, OS, OSVERSION, etc.
  237.         my @keys = qw(NAME VALUE);
  238.         push @keys, qw(HREF) if $key eq 'CODEBASE';
  239.         for (@keys) {
  240.         next unless exists $impl->{$key}[0]{$_};
  241.         $i->{$key} = $o->conv($impl->{$key}[0]{$_});
  242.         last;
  243.         }
  244.     }
  245.     push @impls, $i;
  246.     }
  247.     $o->{parsed}{IMPLEMENTATION} = \@impls;
  248.     $o->{is_complete} = @impls;
  249. }
  250.  
  251. sub conv {
  252.     use Unicode::String qw(utf8);
  253.     my $o = shift;
  254.     my $u = utf8(shift(@_) || '');
  255.     my $use_utf8 = 0;
  256.     for my $env (qw(LC_ALL LC_CTYPE LANG PPM_LANG)) {
  257.     $use_utf8 = 1, last if $ENV{$env} and $ENV{$env} =~ /UTF-8/;
  258.     }
  259.     $u->stringify_as('latin1') unless $use_utf8;
  260.     "$u";
  261. }
  262.  
  263. package PPM::PPD::Base;
  264.  
  265. sub new {
  266.     my $cls = shift;
  267.     my $obj = shift;
  268.     bless $obj, $cls;
  269. }
  270.  
  271. sub AUTOLOAD {
  272.     my $method = $PPM::PPD::Base::AUTOLOAD;
  273.     $method =~ s/^.+:://;
  274.     my $o = shift;
  275.     my $r = $o->{uc($method)};
  276.     defined $r ? $r : '';
  277. }
  278.  
  279. sub version_printable { die }
  280. sub osversion_printable { die }
  281.  
  282. #=============================================================================
  283. # PPM::PPD::Implementation.
  284. # Exposes the following methods:
  285. #
  286. # architecture
  287. # codebase
  288. # os
  289. # osversion_osd
  290. # osversion
  291. # perlcore
  292. # install_script
  293. # uninstall_script
  294. # pythoncore
  295. # 
  296. # prereqs    # returns a list of PPM::PPD::Dependency objects
  297. # language    # returns a PPM::PPD::Language object
  298. #=============================================================================
  299. package PPM::PPD::Implementation;
  300. our @ISA = qw(PPM::PPD::Base);
  301.  
  302. sub osversion_osd {
  303.     my $o = shift;
  304.     my $r = $o->{OSVERSION};
  305.     defined $r ? $r : '';
  306. }
  307.  
  308. sub osversion {
  309.     my $o = shift;
  310.     my $r = $o->osversion_osd;
  311.     PPM::PPD::printify($r);
  312. }
  313.  
  314. sub prereqs {
  315.     my $o = shift;
  316.     return @{$o->{DEPENDENCY} || []};
  317. }
  318.  
  319. sub language {
  320.     my $o = shift;
  321.     $o->{LANGUAGE};
  322. }
  323.  
  324. #=============================================================================
  325. # PPM::PPD::Script
  326. # Exposes the following methods:
  327. #
  328. # exec            # a shell/interpreter to use to run the script
  329. # href            # a script to download
  330. # script        # the content of the script (if href not specified)
  331. #=============================================================================
  332. package PPM::PPD::Script;
  333. our @ISA = qw(PPM::PPD::Base);
  334.  
  335. #=============================================================================
  336. # PPM::PPD::Language.
  337. # Exposes the following methods:
  338. #
  339. # name
  340. # version        # no OSD version for LANGUAGE tag
  341. # type            # one of 'SYNTAX' or 'BINARY'
  342. #
  343. # matches_target($target)    # returns 1 if $target can install PPD, else 0
  344. #=============================================================================
  345. package PPM::PPD::Language;
  346. our @ISA = qw(PPM::PPD::Base);
  347.  
  348. sub matches_target {
  349.     my $o = shift;
  350.     my $t = shift;
  351.     $t->can_install($o->name, $o->version, $o->type);
  352. }
  353.  
  354. #=============================================================================
  355. # PPM::PPD::Dependency.
  356. # Exposes the following methods:
  357. #
  358. # name
  359. # version
  360. # version_osd
  361. # 
  362. # uptodate($ppd)    # returns 1 if the given PPM::PPD object satisfies the
  363. #             # dependency, or 0 otherwise.
  364. #=============================================================================
  365. package PPM::PPD::Dependency;
  366. our @ISA = qw(PPM::PPD::Base);
  367.  
  368. sub version_osd {
  369.     my $o = shift;
  370.     my $r = $o->{VERSION};
  371.     defined $r ? $r : '';
  372. }
  373.  
  374. sub version {
  375.     goto &PPM::PPD::version;
  376. }
  377.  
  378. sub uptodate {
  379.     goto &PPM::PPD::uptodate;
  380. }
  381.  
  382. package PPM::PPD::Search;
  383. @PPM::PPD::Search::ISA = 'PPM::Search';
  384.  
  385. use Data::Dumper;
  386.  
  387. sub matchimpl {
  388.     my $self = shift;
  389.     my ($impl, $field, $re) = @_;
  390.     if ($field eq 'OS')            { return $impl->os =~ $re }
  391.     elsif ($field eq 'OSVERSION')    { return $impl->osversion =~ $re }
  392.     elsif ($field eq 'ARCHITECTURE')    { return $impl->architecture =~ $re}
  393.     elsif ($field eq 'CODEBASE')    { return $impl->codebase =~ $re }
  394.     elsif ($field eq 'PYTHONCORE')    { return $impl->pythoncore =~ $re }
  395.     elsif ($field eq 'PERLCORE')    { return $impl->perlcore =~ $re }
  396.     else {
  397.     warn "unknown search field '$field'" if $^W;
  398.     }
  399. }
  400.  
  401. sub match {
  402.     my $self = shift;
  403.     my ($ppd, $field, $match) = @_;
  404.     my $re = qr/$match/;
  405.     $field = uc($field);
  406.     if ($field eq 'NAME')     { return $ppd->name =~ $re }
  407.     if ($field eq 'AUTHOR')      { return $ppd->author =~ $re }
  408.     if ($field eq 'ABSTRACT')    { return $ppd->abstract =~ $re }
  409.     if ($field eq 'TITLE')       { return $ppd->title =~ $re }
  410.     if ($field eq 'VERSION')     { return $ppd->version_printable =~ $re }
  411.     return (grep { $_ }
  412.         map { $self->matchimpl($_, $field, $re) }
  413.         $ppd->implementations);
  414. }
  415.  
  416. 1;
  417.